Meeting Pearls 1/Meeting Pearls Vol 1 (1994).iso/installed_progs/dev/fsystem-1.2/fio.mod

Text File | 1980-01-01 | 18.4 KB | 681 lines

(* (* $VER: fio 1.2 (24-Nov-93) Copyright © by Lars Düning *) *)

MODULE fio;

(*---------------------------------------------------------------------------
** File-IO for Amiga-Oberon.
**
** Copyright © 1991-1993  Lars Düning  -  All rights reserved.
** Permission granted for non-commercial use.
**---------------------------------------------------------------------------
** CREDIT
**   The module evolved from the io standard module of Amiga-Oberon 1.17.1
**---------------------------------------------------------------------------
** Oberon-2: Amiga-Oberon v3.10, F. Siebert / A+L AG
**---------------------------------------------------------------------------
** [lars] Lars Düning; Am Wendenwehr 25; D-38114-Braunschweig;
**                     Germany; Tel. [phone]
**---------------------------------------------------------------------------
** 25-Feb-91 [lars]
** 28-Feb-91 [lars] improved WriteString().
** 22-Jan-91 [lars] adapted for Oberon v2.00
** 08-Mar-93 [lars] Stdxxx channels added.
** 24-Nov-93 [lars] adapted for Oberon v3.10
**---------------------------------------------------------------------------
*)

(* $OvflChk- $RangeChk- $StackChk- $NilChk- $ReturnChk- $CaseChk- *)

IMPORT
  (* $IF Debug *) Debug, (* $END *)
  d:Dos, e:Exec, wb:Workbench, Icon,
  fs:FSystem,
  ol:OberonLib, s:SYSTEM;

(*-------------------------------------------------------------------------*)

CONST

  StdBufSize * = fs.StdBufSize;  (* default buffer size *)

    (* Open() access modes *)

  newFile * = fs.newFile;   (* excl. access, deletes existing file *)
  oldFile * = fs.oldFile;   (* shared access, file has to exist *)
  update  * = fs.update;    (* excl. access, file may exist *)

    (* Open() operation modes *)

  writeOnly * = fs.writeOnly;
  readOnly  * = fs.readOnly;
  readWrite * = fs.readWrite;

    (* File.status, in fact error codes *)

  ok        * = fs.ok;        (* no error *)
  eof       * = fs.eof;       (* reached end of file *)
  readerr   * = fs.readerr;   (* unspecified read error, ask Dos *)
  writeerr  * = fs.writeerr;  (* unspecified write error, ask Dos *)
  onlyread  * = fs.onlyread;  (* file is read only *)
  onlywrite * = fs.onlywrite; (* file is write only *)
  toofar    * = fs.toofar;    (* seeked beyond the file's ends *)
  outofmem  * = fs.outofmem;  (* ran out of memory *)
  cantopen  * = fs.cantopen;  (* couldn't open file *)
  cantlock  * = fs.cantlock;  (* couldn't lock file *)

TYPE
  FilePtr * = fs.FilePtr;
  File    * = fs.File;

VAR
  stdin   * : d.FileHandlePtr;  (* starting process's standard input *)
  stdout  * : d.FileHandlePtr;  (* starting process's standard outout *)
  stderr  * : d.FileHandlePtr;  (* starting process's standard error output *)

(*-------------------------------------------------------------------------*)

TYPE
  String = ARRAY 40 OF CHAR;

VAR
  l      : LONGINT;
  ftemp  : ARRAY 256 OF CHAR; (* sufficient long! *)
  helpstr: String;


(*-------------------------------------------------------------------------*)
PROCEDURE * RFProc; (* $EntryExitCode- *)

(* Reader function for Exec.RawDoFmt().
*)

BEGIN
  s.INLINE(016C0U,  (* MOVE.B D0,(A3)+ *)
           04E75U); (* RTS             *)
END RFProc;

(*-------------------------------------------------------------------------*)
PROCEDURE Length * (str: ARRAY OF CHAR): LONGINT; (* $EntryExitCode- *)

(* Determine the length of a string.
**
** Arguments:
**   str: the string to check.
**
** Result:
**   The strings length.
**
** The replication of this function here (it belongs to Strings) shows
** clearly the need for INLINE PROCEDUREs.
*)

BEGIN
s.INLINE(0225FH,                  (*     MOVEA.L     (A7)+,A1       *)
         0201FH,                  (*     MOVE.L      (A7)+,D0       *)
         0205FH,                  (*     MOVEA.L     (A7)+,A0       *)
         05380H,                  (*     SUBQ.L      #1,D0          *)
         02200H,                  (*     MOVE.L      D0,D1          *)
         04A18H,                  (* l:  TST.B       (A0)+          *)
         057C9H,0FFFCH,           (*     DBEQ        D1,l           *)
         06708H,                  (*     BEQ         e              *)
         00481H,00001H,00000H,    (*     SUBI.L      #00010000H,D1  *)
         06AF0H,                  (*     BPL         l              *)
         09081H,                  (* e:  SUB.L       D1,D0          *)
         04ED1H);                 (*     JMP         (A1)           *)
END Length;

(*-------------------------------------------------------------------------*)
PROCEDURE write * {"fio.Write"}(VAR out : File; ch: CHAR);
PROCEDURE Write * (VAR out : File; ch: CHAR) : BOOLEAN;

(* Write a character into a file.
**
** Arguments:
**   ch : the character to write.
**   out: the file to write into.
**
** Result:
**   TRUE on success, else FALSE with out.status denoting the error.
*)

BEGIN
  RETURN fs.WriteChar(out,ch);
END Write;


(*-------------------------------------------------------------------------*)
PROCEDURE writeLn * {"fio.WriteLn"}(VAR out : File);
PROCEDURE WriteLn * (VAR out : File) : BOOLEAN;

(* Write a Newline into a file.
**
** Arguments:
**   out: the file to write into.
**
** Result:
**   TRUE on success, else FALSE with out.status denoting the error.
*)

BEGIN
  RETURN fs.WriteChar(out,'\n');
END WriteLn;

(*-------------------------------------------------------------------------*)
(* $CopyArrays- *)
PROCEDURE writeString * {"fio.WriteString"}(VAR out: File; str: ARRAY OF CHAR);
(* $CopyArrays- *)
PROCEDURE WriteString * (VAR out: File; str: ARRAY OF CHAR) : BOOLEAN;

(* Write a string into a file.
**
** Arguments:
**   out: the file to write into.
**   str: the string to write.
**
** Result:
**   TRUE on success, else FALSE with out.status denoting the error.
**
** Newlines are not added.
*)

VAR
  dataLen, aktLen : LONGINT;
  fOk : BOOLEAN;
BEGIN
  dataLen := Length(str);
  fOk := fs.WriteBlock(out,s.ADR(str),dataLen, aktLen);
  IF dataLen # aktLen THEN
    fOk := FALSE;
    out.status := fs.writeerr;
  END;
  RETURN fOk;
END WriteString;

(*-------------------------------------------------------------------------*)
PROCEDURE tab * {"fio.Tab"}(VAR out : File; n: INTEGER);
PROCEDURE Tab * (VAR out : File; n: INTEGER) : BOOLEAN;

(* Output spaces into a file.
**
** Arguments:
**   out : the file to write to.
**   n   : the number of spaces to write.
**
** Result:
**   TRUE on success, else FALSE with out.status denoting the error.
**
** The output is linewrapped to 80 chars per line.
*)

VAR s: ARRAY 80 OF CHAR;
    i: INTEGER;
BEGIN
  WHILE n>0 DO
    i := 0;
    REPEAT
      s[i] := " ";
      INC(i);
    UNTIL (i=79) OR (i=n);
    DEC(n,i);
    s[i] := 0X;
    IF ~WriteString (out, s) THEN
      RETURN FALSE;
    END;
  END;
  RETURN TRUE;
END Tab;

(*-------------------------------------------------------------------------*)
PROCEDURE clear * {"fio.Clear"}(VAR out : File);
PROCEDURE Clear * (VAR out : File) : BOOLEAN;

(* Output a formfeed into a file.
**
** Arguments:
**   out : the file to write to.
**
** Result:
**   TRUE on success, else FALSE with out.status denoting the error.
*)

BEGIN
  RETURN fs.WriteChar(out,'\f');
END Clear;

(*-------------------------------------------------------------------------*)
PROCEDURE format * {"fio.Format"}(VAR out : File; VAR str: String; data:LONGINT);
PROCEDURE Format * (VAR out : File; VAR str: String; data:LONGINT) : BOOLEAN;

(* Output a single formatted item into a file.
**
** Arguments:
**   out  : the file to write to.
**   str  : the format string.
**   data : the item to output.
**
** Result:
**   TRUE on success, else FALSE with file.status denoting the error.
**
** %% => %
**     links  führ.0   min.max Breite  longdata   dez|hex|string|char
**   %  [-]    [0]      [123 [.123] ]     [l]        (d|x|s|c)
**
**   Char is always WORD, even when specified as 'l'!
**   String adresses are always LONG!
**
** Do NOT generate more than 255 chars.
*)

BEGIN
  e.OldRawDoFmt(str,data,RFProc,s.ADR(ftemp));
  RETURN WriteString(out, ftemp);
END Format;

(*-------------------------------------------------------------------------*)
PROCEDURE writeInt * {"fio.WriteInt"}(VAR out: File; x: LONGINT; n: INTEGER);
PROCEDURE WriteInt * (VAR out: File; x: LONGINT; n: INTEGER) : BOOLEAN;

(* Output an integer into a file.
**
** Arguments:
**   out  : the file to write to.
**   x    : the integer to write.
**   n    : the minimal number of characters to write.
**
** Result:
**   TRUE on success, else FALSE with out.status denoting the error.
**
** The integer will be leftadjusted.
*)

BEGIN
  e.OldRawDoFmt('%%%dld',s.ADR(n),RFProc,s.ADR(helpstr));
  RETURN Format(out,helpstr,s.ADR(x));
END WriteInt;


(*-------------------------------------------------------------------------*)
PROCEDURE writeHex * {"fio.WriteHex"}(VAR out : File; x: LONGINT; n: INTEGER);
PROCEDURE WriteHex * (VAR out : File; x: LONGINT; n: INTEGER) : BOOLEAN;

(* Output a hex integer into a file.
**
** Arguments:
**   out  : the file to write to.
**   x    : the integer to write.
**   n    : the minimal number of characters to write.
**
** Result:
**   TRUE on success, else FALSE with out.status denoting the error.
**
** The integer will be leftadjusted and written in base-16 with leading zeroes.
*)

BEGIN
  IF n>=0 THEN (* RawDoFmt makes nonsense for negative numbers of leading zeroes *)
    e.OldRawDoFmt('%%0%dlx',s.ADR(n),RFProc,s.ADR(helpstr));
  ELSE
    n:=-n;
    e.OldRawDoFmt('%%-%dlx',s.ADR(n),RFProc,s.ADR(helpstr));
  END;
  RETURN Format(out,helpstr,s.ADR(x));
END WriteHex;

(*-------------------------------------------------------------------------*)
PROCEDURE read * {"fio.Read"}(VAR in : File; VAR ch: CHAR);
PROCEDURE Read * (VAR in : File; VAR ch: CHAR) : BOOLEAN;

(* Read a character from a file.
**
** Arguments:
**   in : the file to read from.
**   ch : variable taking the character to read
**
** Result:
**   TRUE on success, else FALSE with file.status denoting the error.
**   ch: the character read.
*)

BEGIN
  RETURN fs.ReadChar(in,ch);
END Read;

(*-------------------------------------------------------------------------*)
PROCEDURE readString * {"fio.ReadString"}(VAR in : File; VAR str: ARRAY OF CHAR);
PROCEDURE ReadString * (VAR in : File; VAR str: ARRAY OF CHAR) : BOOLEAN;

(* Read a string from a file.
**
** Arguments:
**   in  : the file to read from.
**   str : variable taking the string to read
**
** Result:
**   TRUE on success, else FALSE with file.status denoting the error.
**   str: the string read.
**
** The function reads until an \0 or \n is encountered (which won't be
** stored), or the buffer is exhausted. If possible, the string
** is terminated by \0.
*)

BEGIN
  RETURN fs.ReadString (in, str);
END ReadString;

(*-------------------------------------------------------------------------*)
PROCEDURE readLong * {"fio.ReadLong"}(VAR in : File; VAR x: LONGINT);
PROCEDURE ReadLong * (VAR in : File; VAR x: LONGINT): BOOLEAN;

(* Read a long integer from a file.
**
** Arguments:
**   in : the file to read from.
**   x  : variable taking the long integer read
**
** Result:
**   TRUE on success, else FALSE with file.status denoting the error.
**     If FALSE is returned, but in.status is 'ok', then the read characters
**     do not form a legal number.
**   x: the long integer read.
**
** Linebreaks after a number aren't read.
** Leading whitespace will be ignored.
*)

VAR
  ch: CHAR;
  d: LONGINT;
  neg: BOOLEAN;
  isInt : BOOLEAN;
  fOk : BOOLEAN;
BEGIN
  x := 0; isInt := FALSE;
  neg := FALSE;

  (* Skip any preceeding spaces/tabs *)
  REPEAT
    IF ~Read (in, ch) THEN RETURN FALSE; END;
  UNTIL (ch # ' ') AND (ch # '\t');

  (* Check for sign *)
  IF (ch="-") OR (ch = "+") THEN
    neg := (ch = "-");
    IF ~Read (in, ch) THEN RETURN FALSE; END;
  END;

  (* Read digits *)
  LOOP
    CASE ch OF
      "0".."9": d := ORD(ch)-ORD("0");
    ELSE EXIT
    END;
    IF (MAX(LONGINT)-d) DIV 10 >= x THEN
      x := 10*x+d; isInt := TRUE;
      fOk := Read (in, ch);
      IF ~fOk THEN EXIT; END;
    ELSE
      isInt := FALSE;
      EXIT
    END;
  END;
  IF isInt AND neg THEN x := -x; END;
  IF fOk THEN fOk := fs.Backward (in, 1); END;
  RETURN isInt & fOk;
END ReadLong;

(*-------------------------------------------------------------------------*)
PROCEDURE readInt * {"fio.ReadInt"}(VAR in : File; VAR x: INTEGER);
PROCEDURE ReadInt * (VAR in : File; VAR x: INTEGER): BOOLEAN;

(* Read an integer from a file.
**
** Arguments:
**   in : the file to read from.
**   x  : variable taking the integer read
**
** Result:
**   TRUE on success, else FALSE with file.status denoting the error.
**     If FALSE is returned, but in.status is 'ok', then the read characters
**     do not form a legal number.
**   x: the integer read.
**
** Linebreaks after a number aren't read.
** Leading whitespace will be ignored.
*)

VAR
  l: LONGINT;
BEGIN
  IF ReadLong(in,l) AND (l>=MIN(INTEGER)) AND (l<=MAX(INTEGER)) THEN
    x := SHORT(l);
    RETURN TRUE;
  END;
  RETURN FALSE;
END ReadInt;

(*-------------------------------------------------------------------------*)
PROCEDURE readShort * {"fio.ReadShort"}(VAR in : File; VAR x: SHORTINT);
PROCEDURE ReadShort * (VAR in : File; VAR x: SHORTINT): BOOLEAN;

(* Read a short integer from a file.
**
** Arguments:
**   in : the file to read from.
**   x  : variable taking the short integer read
**
** Result:
**   TRUE on success, else FALSE with file.status denoting the error.
**     If FALSE is returned, but in.status is 'ok', then the read characters
**     do not form a legal number.
**   x: the short integer read.
**
** Linebreaks after a number aren't read.
** Leading whitespace will be ignored.
*)

VAR
  l: LONGINT;
BEGIN
  IF ReadLong(in,l) AND (l>=MIN(SHORTINT)) AND (l<=MAX(SHORTINT)) THEN
    x := SHORT(SHORT(l));
    RETURN TRUE;
  END;
  RETURN FALSE;
END ReadShort;

(*-------------------------------------------------------------------------*)
PROCEDURE readHex * {"fio.ReadHex"}(VAR in : File; VAR x: LONGINT);
PROCEDURE ReadHex * (VAR in : File; VAR x: LONGINT): BOOLEAN;

(* Read a long integer in base-16 notation from a file.
**
** Arguments:
**   in : the file to read from.
**   x  : variable taking the long integer read
**
** Result:
**   TRUE on success, else FALSE with file.status denoting the error.
**     If FALSE is returned, but in.status is 'ok', then the read characters
**     do not form a legal number.
**   x: the long integer read.
**
** Linebreaks after a number aren't read.
** Leading whitespace will be ignored.
*)

VAR
  ch: CHAR;
  d: LONGINT;
  isHex: BOOLEAN;
  fOk : BOOLEAN;
BEGIN
  x := 0; isHex := FALSE;

  (* Skip any preceeding spaces/tabs *)
  REPEAT
    IF ~Read (in, ch) THEN RETURN FALSE; END;
  UNTIL (ch # ' ') AND (ch # '\t');

  (* Read digits *)
  LOOP
    CASE ch OF
    | '0'..'9': DEC(ch,ORD("0"));
    | 'A'..'F': DEC(ch,ORD("A")-10);
    | 'a'..'f': DEC(ch,ORD("a")-10);
    ELSE EXIT END;
    d := ORD(ch);
    IF (MAX(LONGINT)-d) DIV 16 >= x THEN
      x := 16*x+d; isHex := TRUE;
      fOk := Read (in, ch);
      IF ~fOk THEN EXIT; END;
    ELSE isHex := FALSE; EXIT END;
  END;

  IF fOk THEN fOk := fs.Backward (in, 1); END;
  RETURN isHex & fOk;
END ReadHex;

(*-------------------------------------------------------------------------*)
(* $CopyArrays- *)
PROCEDURE Use * (VAR    file: File
                ;       name: ARRAY OF CHAR
                ;    accMode: INTEGER
                ;    opMode : INTEGER
                ;    bufsize: LONGINT
                ): BOOLEAN;


(* Open a file according to access and operation mode.
**
** Arguments:
**   file: the empty(!) File structure to fill in.
**   name: the name of the file to open (will be copied into file).
**   accMode: the access mode to use.
**   opMode : the operation mode to use.
**   bufSize: size of the buffer to allocate, must be at least 1.
**
** Result:
**   TRUE on success, else FALSE with file.status denoting the error.
**
** A bufsize of 1 will result in unbuffered io.
*)

BEGIN
  RETURN fs.Use (file, name, accMode, opMode, bufsize);
END Use;

(*-------------------------------------------------------------------------*)
(* $CopyArrays- *)
PROCEDURE open * (VAR    file: File
                 ;       name: ARRAY OF CHAR
                 ;    accMode: INTEGER
                 ): BOOLEAN;

(* Open a file for read/write with a default sized buffer.
**
** Arguments:
**   file: the empty(!) File structure to fill in.
**   name: the name of the file to open (will be copied into file).
**   accMode: the access mode to use.
**
** Result:
**   TRUE on success, else FALSE with file.status denoting the error.
**
** The allocated buffer will be of StdBufSize.
** The file will be opened for reading and writing.
*)

BEGIN
  RETURN Use (file, name, accMode, readWrite, StdBufSize);
END open;

(*-------------------------------------------------------------------------*)
PROCEDURE close * {"fio.Close"} (VAR file: File);
PROCEDURE Close * (VAR file: File): BOOLEAN;

(* Close the file.
**
** Arguments:
**   file: the file to close.
**
** Result:
**   TRUE on success, else FALSE with file.status denoting the error.
**
** Before closing, all changed data is written out using FlushBuf().
*)

BEGIN
  RETURN fs.Close (file);
END Close;

(*-------------------------------------------------------------------------*)
PROCEDURE StdIn * () : d.FileHandlePtr;

(* The current processes standard input.
**
** Result:
**   The FileHandle of standard input or NIL;
**
** Don't call this function for simple tasks!
*)

VAR
  me : d.ProcessPtr;
BEGIN
  me := e.FindTask(NIL);
  RETURN me.cis;
END StdIn;

(*-------------------------------------------------------------------------*)
PROCEDURE StdOut * () : d.FileHandlePtr;

(* The current processes standard output.
**
** Result:
**   The FileHandle of standard output or NIL;
**
** Don't call this function for simple tasks!
*)

  VAR
    me : d.ProcessPtr;
BEGIN
  me := e.FindTask(NIL);
  RETURN me.cos;
END StdOut;


(*-------------------------------------------------------------------------*)
PROCEDURE StdErr * () : d.FileHandlePtr;

(* The current processes standard error output.
**
** Result:
**   The FileHandle of standard error output or NIL;
**
** Don't call this function for simple tasks!
** For OS < 2.0, stderr is stdout.
*)

  VAR
    me : d.ProcessPtr;
    stderr : d.FileHandlePtr;
BEGIN
  me := e.FindTask(NIL);
  IF e.exec.libNode.version < 37 THEN
    RETURN me.cos;
  END;
  RETURN me.ces;
END StdErr;

(*=========================================================================*)

BEGIN
  stdin := StdIn();
  stdout := StdOut();
  stderr := StdErr();
END fio.

(***************************************************************************)